home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / tdecl / class.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  10.9 KB  |  306 lines  |  [TEXT/CCL2]
  1. ;;; Before classes are converted, the super class relation is computed.
  2. ;;; This sets up the super and super* field of each class and
  3. ;;; checks for the following errors:
  4. ;;;  Wrong tyvar in context
  5. ;;;  cyclic class structure
  6. ;;;  Non-class in context
  7.  
  8.  
  9. (define (signal-super-class-tyvar-error class class-var tyvar)
  10.   (recoverable-error 'super-class-tyvar-error
  11.     "The context for class ~A must only refer to type variable ~A.~%~
  12.      Type variable ~A cannot be used here."
  13.     (class-ref-name class) class-var tyvar))
  14.  
  15. (define (compute-class-super* class)
  16.   (setf (class-super* class) 
  17.     (reverse (compute-super*-1 '() (class-super class))))
  18.   (when (memq class (class-super* class))
  19.       (signal-cyclic-class-structure (class-super* class))))
  20.  
  21. (define (compute-super*-1 result pending)
  22.   (if (null? pending)
  23.       result
  24.       (let ((c (forward-def (car pending))))
  25.     (if (memq c result)
  26.         (compute-super*-1 result (cdr pending))
  27.         (compute-super*-1 (cons (car pending) result)
  28.                   (append (class-super c) pending))))))
  29.  
  30. (define (signal-cyclic-class-structure classes)
  31.   (fatal-error 'cyclic-class-structure
  32.     "There is a cycle in the superclass relation involving these classes:~%~a"
  33.     classes))
  34.  
  35.  
  36. ;;;  This sets up the following fields in the class entry:
  37. ;;;    instances '()
  38. ;;;    defaults = ast for defaults
  39. ;;;    kind
  40. ;;;    methods
  41. ;;;    signatures
  42. ;;;    method-vars
  43. ;;;    selectors
  44. ;;;  Each method is initialized with
  45. ;;;    class
  46. ;;;    signature
  47. ;;;    type
  48. ;;;  Errors detected:
  49. ;;;   signature doesnt reference class 
  50.  
  51. (define (class->def class-decl)
  52.  (remember-context class-decl
  53.   (with-slots class-decl (super-classes class class-var decls) class-decl
  54.    (let ((class (class-ref-class class))
  55.      (super '()))
  56.      (setf (class-instances class) '())
  57.      (setf (class-kind class) (find-class-kind class))
  58.      (dolist (context super-classes)
  59.     (with-slots context (class tyvar) context
  60.       (when (not (eq? class-var tyvar))
  61.         (signal-super-class-tyvar-error class-decl class-var tyvar))
  62.       (resolve-class class)
  63.       (let ((super-def (class-ref-class class)))
  64.         (when (not (eq? super-def *undefined-def*))
  65.            (push super-def super)))))
  66.      (setf (class-super class) (reverse super))
  67.      (setf (class-tyvar class) class-var)
  68.      ; sets up defaults, method signatures
  69.      (init-methods class decls)
  70.      (setf (class-n-methods class) (length (class-method-vars class)))
  71.      (setf (class-runtime-var class)
  72.        (make-runtime-var class "-class" (core-symbol "Class")))
  73.      class))))
  74.  
  75. (define (find-class-kind class)
  76.   (cond ((not (module-prelude? *module*))
  77.      'other)
  78.     ((memq class
  79.            (list (core-symbol "Eq") (core-symbol "Ord")
  80.              (core-symbol "Text") (core-symbol "Binary")
  81.              (core-symbol "Ix") (core-symbol "Enum")))
  82.      'Standard)
  83.     ((memq class
  84.            (list (core-symbol "Num") (core-symbol "Real")
  85.              (core-symbol "Integral") (core-symbol "Fractional")
  86.              (core-symbol "Floating") (core-symbol "RealFrac")
  87.              (core-symbol "RealFloat")))
  88.              'Numeric)
  89.     (else
  90.      'other)))
  91.  
  92. (define (init-methods class decls)
  93.  (let* ((tyvar (class-tyvar class))
  94.         (class-context (**context (**class/def class) tyvar))
  95.     (annotations '()))
  96.   (dolist (decl decls)
  97.    (remember-context decl
  98.     (cond ((is-type? 'signdecl decl)
  99.        (let* ((signature (signdecl-signature decl))
  100.           (vars (resolve-signature signature)))
  101.          (when (not (memq tyvar vars))
  102.            (signal-class-sig-ignores-type signature tyvar class))
  103.          ;; Note: signature does not include defined class yet
  104.          (dolist (context (signature-context signature))
  105.                (when (eq? tyvar (context-tyvar context))
  106.          (signal-method-constrains-class-tyvar
  107.            (car (signdecl-vars decl)) class signature context)))
  108.          (setf signature (rename-class-sig-vars signature tyvar))
  109.          (let ((gtype (ast->gtype (cons class-context
  110.                         (signature-context signature))
  111.                       (signature-type signature))))
  112.             (dolist (var-ref (signdecl-vars decl))
  113.              (let ((var (var-ref-var var-ref)))
  114.            (setf (var-type var) gtype)
  115.            (setf (method-var-method-signature var) signature))))))
  116.       ((annotation-decls? decl)
  117.        (setf annotations (append (annotation-decls-annotations decl)
  118.                      annotations)))
  119.       (else  ; decl must be a default definition
  120.        (let ((vars (collect-pattern-vars (valdef-lhs decl))))
  121.          (dolist (var-ref vars)
  122.                (let* ((method-name (var-ref-name var-ref))
  123.               (method-var (resolve-toplevel-name method-name)))
  124.           (if (and method-var (method-var? method-var)
  125.                (eq? (method-var-class method-var) class))
  126.            (let ((default-var
  127.                (make-new-var
  128.                  (string-append
  129.                    "default-"
  130.                    (symbol->string (def-name method-var))))))
  131.              (setf (var-ref-var var-ref) default-var)
  132.              (setf (var-ref-name var-ref) (def-name default-var))
  133.              (when (not (eq? (method-var-default method-var) '#f))
  134.               (signal-multiple-definition-of-default method-name class))
  135.              (setf (method-var-default method-var) default-var)
  136.              (let* ((sig (method-var-method-signature method-var))
  137.                 (context (cons class-context
  138.                        (signature-context sig)))
  139.                 (new-sig (**signature context
  140.                           (signature-type sig))))
  141.                (add-new-module-signature default-var new-sig)))
  142.            (signal-default-not-in-class method-name class)))))
  143.          (add-new-module-decl decl)))))
  144.   (dolist (a annotations)
  145.     (cond ((annotation-value? a)
  146.        (recoverable-error 'misplaced-annotation
  147.                   "Misplaced annotation: ~A~%" a))
  148.       (else
  149.        (dolist (name (annotation-decl-names a))
  150.          (attach-default-annotation
  151.             name (annotation-decl-annotations a) class)))
  152.          ))))
  153.  
  154. (define (attach-default-annotation name anns class)
  155.   (let ((var-ref (**var name)))
  156.     (resolve-var var-ref)
  157.     (let ((method-var (var-ref-var var-ref)))
  158.       (when (not (eq? method-var *undefined-def*))
  159.      (if (and (method-var? method-var)
  160.           (eq? (method-var-class method-var) class))
  161.          (let ((dvar (method-var-default method-var)))
  162.            (if dvar
  163.           (setf (var-annotations dvar)
  164.             (append anns (var-annotations dvar)))
  165.           (recoverable-error 'bad-class-annotation
  166.             "Method ~A has no default to annotate"
  167.             name)))
  168.          (recoverable-error 'bad-class-annotation
  169.                 "~A is not in the defined class ~A"
  170.             name class))))))
  171.  
  172. ;;; This does a few things that require definitions of superclasses and
  173. ;;; type synonyms.  For interfaces, this must be done after dangling
  174. ;;; references are resolved.
  175.  
  176. (define (setup-class-slots class)
  177.  (compute-class-super* class)
  178.  (setf (class-dict-size class)
  179.        (+ (class-n-methods class) (length (class-super* class)))))
  180.  
  181. (define (signal-class-sig-ignores-type signature tyvar class)
  182.   (phase-error 'class-sig-ignores-type
  183.     "The method signature ~a in class ~A does not reference~%~
  184.      the overloaded type ~A."
  185.     (sz signature 20) (get-object-name class) tyvar))
  186.  
  187.  
  188. (define (signal-method-constrains-class-tyvar m class sig context)
  189.   (phase-error 'method-constrains-class-tyvar
  190.     "The signature of method ~A in class ~A, ~A,~%~
  191.      may not further constrain the type associated with the class.~%~
  192.      The context ~A can not be used in this signature."
  193.    m (get-object-name class) sig context))
  194.  
  195. (define (signal-multiple-definition-of-default method-name class)
  196.   (phase-error 'multiple-definition-of-default
  197.    "There are multiple definitions of the default operation for method ~A~%~
  198.     in class ~A."
  199.    method-name (get-object-name class)))
  200.  
  201. (define (signal-default-not-in-class method-var class)
  202.   (phase-error 'default-not-in-class
  203.      "Definitions within class ~A are limited to the methods in this class.~%~
  204.       The definition of ~A is not allowed here."
  205.    (get-object-name class) method-var))
  206.        
  207. (define (create-selector-functions class interface?)
  208.   (let ((res '()))
  209.     (dolist (c (cons class (class-super* class)))
  210.       (dolist (m (class-method-vars c))
  211.     (let ((var (make var
  212.               (name (string->symbol
  213.                  (string-append "sel-"
  214.                     (symbol->string (def-name class))
  215.                     "/"
  216.                     (symbol->string (def-name m)))))
  217.               (module (def-module class))
  218.               (unit (def-unit class))
  219.               (toplevel? '#t))))
  220.       (setf (var-selector-fn? var) '#t)
  221.       (push (tuple m var) res)
  222.       (unless interface?
  223.         (let ((arity (count-type-arity (gtype-type (var-type m)))))
  224.           (add-new-module-def var (create-selector-code class m arity))))))
  225.     (setf (class-selectors class) res))))
  226.  
  227. (define (create-selector-args arity)
  228.   (let ((result  '()))
  229.     (dotimes (i arity)
  230.       (declare (ignorable i))
  231.       (push (create-local-definition (gensym "arg")) result))
  232.     (nreverse result)))
  233.  
  234. (define (create-selector-code c m arity)
  235.   (let ((var   (create-local-definition '|d|))
  236.     (args  (create-selector-args arity)))
  237.     (setf (var-force-strict? var) '#t)
  238.     (let ((body (create-selector-code-1 c m (**var/def var))))
  239.       (**lambda/pat (cons (**var-pat/def var)
  240.               (map (function **var-pat/def) args))
  241.             (if (null? args)
  242.             body
  243.             (**app/l body
  244.                  (map (function **var/def) args)))))))
  245.  
  246. (define (create-selector-code-1 class method d)
  247.   (let ((mcl (method-var-class method)))
  248.     (cond ((eq? mcl class)
  249.        (**dsel/method class method d))
  250.       (else
  251.        (**dsel/method mcl method (**dsel/dict class mcl d))))))
  252.          
  253. ;;; The following code is for the alpha conversion of method
  254. ;;; signatures.  The class tyvar is unchanged; all others are renamed.
  255. ;;; This is needed because all method types are combined to form the
  256. ;;; dictionary signature and aliasing among different tyvars should be
  257. ;;; prevented.
  258.  
  259. (define (rename-class-sig-vars signature tyvar)
  260.   (mlet (((new-context env1)
  261.       (rename-context-vars (signature-context signature)
  262.                    (list (tuple tyvar tyvar))))
  263.      ((new-type _)
  264.       (rename-type-vars (signature-type signature) env1)))
  265.       (**signature new-context new-type)))
  266.  
  267. (define (rename-context-vars contexts env)
  268.   (if (null? contexts)
  269.       (values '() env)
  270.       (mlet (((new-tyvar env1)
  271.           (rename-sig-tyvar (context-tyvar (car contexts)) env))
  272.          ((rest env2)
  273.           (rename-context-vars (cdr contexts) env1)))
  274.        (values (cons (**context (context-class (car contexts)) new-tyvar) rest)
  275.            env2))))
  276.  
  277. (define (rename-type-vars type env)
  278.   (if (tyvar? type)
  279.       (mlet (((tyvar env1)
  280.           (rename-sig-tyvar (tyvar-name type) env)))
  281.      (values (**tyvar tyvar) env1))
  282.       (mlet (((new-types env1) (rename-type-vars/l (tycon-args type) env)))
  283.         (values (**tycon/def (tycon-def type) new-types) env1))))
  284.  
  285. (define (rename-type-vars/l types env)
  286.   (if (null? types)
  287.       (values '() env)
  288.       (mlet (((type1 env1) (rename-type-vars (car types) env))
  289.          ((new-types env2) (rename-type-vars/l (cdr types) env1)))
  290.           (values (cons type1 new-types) env2))))
  291.  
  292. (define (rename-sig-tyvar tyvar env)
  293.   (let ((res (assq tyvar env)))
  294.     (if (eq? res '#f)
  295.     (let ((new-tyvar (gentyvar (symbol->string tyvar))))
  296.       (values new-tyvar (cons (tuple tyvar new-tyvar) env)))
  297.     (values (tuple-2-2 res) env))))
  298.  
  299. (define *tyvar-counter* 0)
  300.  
  301. ;;; This generates a new interned tyvar name
  302.  
  303. (define (gentyvar root)
  304.   (incf *tyvar-counter*)
  305.   (string->symbol (format '#f "~A-~A" root *tyvar-counter*)))
  306.